An Invitation to the Roland World of Music/Roland - An Invitation To The Roland World Of Music.bin/vb/cooltool/sysex/sysex.frm

Text File | 1995-04-20 | 19KB | 625 lines

VERSION 2.00
Begin Form FormSysex
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   1  'Fixed Single
   Caption         =   "MIDI CoolTools - System Exclusive Example"
   Height          =   4005
   Icon            =   SYSEX.FRX:0000
   Left            =   45
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3315
   ScaleWidth      =   9255
   Top             =   1125
   Width           =   9375
   Begin Frame FrameSysexList
      BackColor       =   &H00C0C0C0&
      Caption         =   "Sysex Bank List"
      Height          =   1755
      Left            =   30
      TabIndex        =   11
      Top             =   30
      Width           =   4185
      Begin ListBox ListSysex
         Height          =   1395
         Left            =   120
         MultiSelect     =   2  'Extended
         TabIndex        =   12
         Top             =   270
         Width           =   3825
      End
   End
   Begin MIDIOutput MIDIOutput1
      DeviceID        =   0
      Left            =   540
      Top             =   3270
      VolumeLeft      =   0
      VolumeRight     =   0
   End
   Begin MIDIInput MIDIInput1
      DeviceID        =   0
      Left            =   60
      MaxSysexSize    =   32000
      MessageEventEnable=   0   'False
      Top             =   3270
   End
   Begin CommonDialog CMDialog1
      DialogTitle     =   "System Exclusive Binary Files"
      Filter          =   "(*.syx) Sysex |*.syx|"
      Left            =   1020
      Top             =   3270
   End
   Begin Frame FrameSysexEdit
      BackColor       =   &H00C0C0C0&
      Caption         =   "Edit MIDI System Exclusive Message"
      Height          =   1365
      Left            =   30
      TabIndex        =   9
      Top             =   1860
      Width           =   9135
      Begin TextBox TextSysex
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   1005
         Left            =   90
         MultiLine       =   -1  'True
         ScrollBars      =   1  'Horizontal
         TabIndex        =   10
         Text            =   "Text Message"
         Top             =   270
         Width           =   8955
      End
   End
   Begin Frame Frame5
      BackColor       =   &H00C0C0C0&
      Caption         =   "MIDI Filter"
      Height          =   1755
      Left            =   7410
      TabIndex        =   6
      Top             =   30
      Width           =   1755
      Begin CheckBox CheckMIDIFilter1
         BackColor       =   &H00C0C0C0&
         Caption         =   "Active Sensing"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   225
         Left            =   150
         TabIndex        =   1
         Top             =   1350
         Value           =   1  'Checked
         Width           =   1395
      End
      Begin CheckBox CheckMIDIFilter2
         BackColor       =   &H00C0C0C0&
         Caption         =   "Undefined F9"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   225
         Left            =   150
         TabIndex        =   8
         Top             =   840
         Value           =   1  'Checked
         Width           =   1335
      End
      Begin CheckBox CheckMIDIFilter3
         BackColor       =   &H00C0C0C0&
         Caption         =   "MIDI Time Clock"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   225
         Left            =   150
         TabIndex        =   7
         Top             =   330
         Value           =   1  'Checked
         Width           =   1455
      End
   End
   Begin Frame Frame4
      BackColor       =   &H00C0C0C0&
      Caption         =   "Receive [In] System Exclusive"
      Height          =   705
      Left            =   4290
      TabIndex        =   4
      Top             =   30
      Width           =   3075
      Begin CommandButton CmdReceiveSysex
         Caption         =   "Receive Sysex Message"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   315
         Left            =   60
         TabIndex        =   5
         Top             =   270
         Width           =   2925
      End
   End
   Begin Frame Frame3
      BackColor       =   &H00C0C0C0&
      Caption         =   "Send [Out] System Exclusive"
      Height          =   735
      Left            =   4290
      TabIndex        =   2
      Top             =   750
      Width           =   3075
      Begin CommandButton CmdSendSysex
         Caption         =   "Send Selected Sysex Message"
         FontBold        =   0   'False
         FontItalic      =   0   'False
         FontName        =   "MS Sans Serif"
         FontSize        =   8.25
         FontStrikethru  =   0   'False
         FontUnderline   =   0   'False
         Height          =   315
         Left            =   60
         TabIndex        =   3
         Top             =   300
         Width           =   2925
      End
   End
   Begin Label LblInQueue
      BackColor       =   &H00000000&
      Caption         =   " MIDI Sysex Status"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      ForeColor       =   &H0000FF00&
      Height          =   225
      Left            =   4290
      TabIndex        =   0
      Top             =   1530
      Width           =   3075
   End
   Begin Menu mnuFile
      Caption         =   "&File"
      Begin Menu mnuFileLoadBank
         Caption         =   "&Load Bank"
         Shortcut        =   ^L
      End
      Begin Menu MnuSaveBankAs
         Caption         =   "Save Bank &As..."
         Shortcut        =   ^A
      End
      Begin Menu mnuFileSep1
         Caption         =   "-"
      End
      Begin Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
   Begin Menu mnuMidi
      Caption         =   "&MIDI"
      Begin Menu mnuMidiSetup
         Caption         =   "&Setup..."
      End
      Begin Menu mnuMidiThru
         Caption         =   "&Thru"
         Checked         =   -1  'True
      End
   End
End

Option Explicit

Dim DisplayBufferString(200) As String
Dim UserMessage As String

Sub CheckMIDIFilter1_Click ()
    If CheckMIDIFilter1.Value = 0 Then
    MIDIInput1.Filter(FILTER_F9) = False
    Else
    MIDIInput1.Filter(FILTER_F9) = True
    End If
End Sub

Sub CheckMIDIFilter2_Click ()
    If CheckMIDIFilter2.Value = 0 Then
    MIDIInput1.Filter(FILTER_ACTIVE_SENSE) = False
    Else
    MIDIInput1.Filter(FILTER_ACTIVE_SENSE) = True
    End If
End Sub

Sub CheckMIDIFilter3_Click ()
    If CheckMIDIFilter3.Value = 0 Then
    MIDIInput1.Filter(FILTER_CLOCK) = False
    Else
    MIDIInput1.Filter(FILTER_CLOCK) = True
    End If
End Sub

Sub CmdReceiveSysex_Click ()
    MIDIInput1.Action = MIDIIN_START


    ' MIDI Data is being received
    LblInQueue.Caption = " Waiting for data..."

End Sub

Sub CmdReceiveSysex_LostFocus ()
    'UserMessage string is used when data is being received.
    'It is used only to show that progress is happening
    UserMessage = " Receiving data..."
End Sub

Sub CmdSendSysex_Click ()
    Dim I As Integer
    Dim n As Integer
    Dim SysexMessage As String
    Dim StringPosition As Integer


    '**NOTE**
    '
    'If all you want to do is send simple sysex messages, you can format
    'them as simple as this example.  (A Sysex message is sent which resets
    'the Roland SoundCanvas SC-88 to General MIDI mode)
    '
    'Midioutput1.message = &HF0
    'Midioutput1.Buffer = Chr$(&HF0) + Chr$(&H7E) + Chr$(&H7F) + Chr$(9) + Chr$(1) + Chr$(&HF7)
    'Midioutput1.Action = MIDIOUT_SEND
    '
    'In this example the first and last bytes (&HF0 and &HF7) signal the
    'beginning and end of a Sysex message.  The middle bytes are the Sysex
    'message contents.


    ' MIDI Data is being sent
    LblInQueue.Caption = " Sending data..."
    LblInQueue.Refresh

    'Look through ListSysex to see if you have selected some sysex
    'messages to send
    For I = 0 To ListSysex.ListCount - 1
    'When we first received the sysex message we reformated
    'it to make it easier to edit.  Now since we're going to send it,
    'we've got to get it back in its original format
    If ListSysex.Selected(I) = True Then
        SysexMessage = ""
        ListSysex.ListIndex = I
        '
        ' Must tell MIDI CoolTools that this is a sysex message
        MIDIOutput1.Message = &HF0

        'Start formating complete sysex message
        SysexMessage = Chr$("&H" + Left(DisplayBufferString(I), 2))

        'Starting position of InStr search
        n = 3

        'We're going into this loop until we've reformated the complete
        'sysex message
        Do While Len(DisplayBufferString(I)) > n
        '
        'Since we've got a bunch of spaces " " that we've got
        'to find in our reformating, we're going to use the
        'InStr function to help us find them.  Look in the VB
        'Help file if you don't understand InStr!
        StringPosition = InStr(n, DisplayBufferString(I), " ")
        '
        'If 0 then we'll not put in the &H
        If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "0" Then
            SysexMessage = SysexMessage & Chr$(Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
        Else
            'If not 0 but just null, then we do nothing
            If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "" Then
            'null
            Else
            SysexMessage = SysexMessage & Chr$("&H" & Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
            End If
        End If
        n = StringPosition + 2
        Loop

        'Complete sysex message is all reformated and now ready
        'to be queued
        MIDIOutput1.Buffer = SysexMessage
        MIDIOutput1.Action = MIDIOUT_QUEUE

    End If
    Next I
    MIDIOutput1.Action = MIDIOUT_START
End Sub

Sub Form_Load ()
    Dim I As Integer

    'UserMessage string is used when data is being received.
    'It is used only to show that progress is happening
    UserMessage = " Receiving data..."

    ' Center the form on the screen
    'Move (Screen.Width - Width) \ 2, (Screen.Height - Height) \ 2

    FormSysex.Show
    MIDISetupForm.Show MODAL
End Sub

Sub Form_Unload (Cancel As Integer)

    ' Stop the MIDI In
    MIDIInput1.Action = MIDIIN_STOP

    ' Close MIDI In
    MIDIInput1.Action = MIDIIN_CLOSE


    ' Close MIDI Out
    MIDIOutput1.Action = MIDIOUT_CLOSE

    End
End Sub

Sub ListSysex_Click ()
    'Display the sysex message that is stored in DisplayBufferString
    TextSysex.Text = DisplayBufferString(ListSysex.ListIndex)
End Sub

Sub MIDIInput1_Error (ErrorCode As Integer, ErrorMessage As String)
    '
    ' Midi input error, display message
    '
    MsgBox ErrorMessage

End Sub

Sub MIDIInput1_Message ()
    Dim n As Integer
    Dim SysexListCount As Integer

    SysexListCount = ListSysex.ListCount


    '
    ' The MIDIInput1.SysexMaxSize property is set to 5000 bytes in this
    ' example.  For larger system exclusive messages, increase this
    ' property. If you are not going to receive system exclusive
    ' message, set the SysexMaxSize property to 0.
    '

    '
    'This do while loop allows you to take all the messages that are
    'waiting in the message queue.

    Do While MIDIInput1.MessageCount > 0 And Len(MIDIInput1.Buffer) > 0
    'Show the users that data is coming in
    UserMessage = UserMessage + "...."
    LblInQueue.Caption = UserMessage
    LblInQueue.Refresh

    '
    'Add each Message to the List box so that the users can click
    'through each message.  We'll set this up to allow the users
    'to view and edit the complete sysex message
    ListSysex.AddItem "Message " & Str(SysexListCount) & " Length=" & Str(Len(MIDIInput1.Buffer))

    'A complete sysex message has been received into the
    'MIDIInput.Buffer
    '
    'Now we'll put the first data byte of sysex message into
    'the DisplayBufferString.
    DisplayBufferString(SysexListCount) = Hex(Asc(Left(MIDIInput1.Buffer, 1)))

    'Now we're going to go through the remaining portion of the
    'sysex message and get it ready to display.  We'll then be able
    'to view and edit the complete sysex message.
    For n = 2 To Len(MIDIInput1.Buffer)
        DisplayBufferString(SysexListCount) = DisplayBufferString(SysexListCount) & " " & Hex(Asc(Mid(MIDIInput1.Buffer, n, 1)))
    Next n

    '
    'DisplayBufferString now contains the sysex message in a viewable
    'format
    '
    'Remove the MIDI data from the MIDI IN queue
    '
    MIDIInput1.Action = MIDIIN_REMOVE
    Loop


    ' IF the buffer is > 0 then we've received some sysex data
    If Len(DisplayBufferString(SysexListCount)) > 0 Then
    LblInQueue.Caption = " Sysex Data Received!"
    ElseIf mnuMidiThru.Checked = True Then
    'If MIDI Thru is checked in the menu, send non-sysex data out
    MIDIOutput1.Message = MIDIInput1.Message
    MIDIOutput1.Data1 = MIDIInput1.Data1
    MIDIOutput1.Data2 = MIDIInput1.Data2
    MIDIInput1.Action = MIDIIN_REMOVE
    MIDIOutput1.Action = MIDIOUT_START
    MIDIOutput1.Action = MIDIOUT_SEND
    MIDIOutput1.Action = MIDIOUT_STOP
    End If
End Sub

Sub MIDIOutput1_Error (ErrorCode As Integer, ErrorMessage As String)
    '
    ' Midi output error, display message
    '
    MsgBox ErrorMessage
End Sub

Sub MIDIOutput1_QueueEmpty ()
    '
    'Once queue becomes empty, get ready to record again
    '
    MIDIOutput1.Action = MIDIOUT_STOP

    ' MIDI Data is being received
    LblInQueue.Caption = " Data Sent!"

End Sub

Sub mnuFileExit_Click ()
    ' Stop the MIDI In
    MIDIInput1.Action = MIDIIN_STOP

    ' Close MIDI In
    MIDIInput1.Action = MIDIIN_CLOSE


    ' Close MIDI Out
    MIDIOutput1.Action = MIDIOUT_CLOSE

    End
End Sub

Sub mnuFileLoadBank_Click ()
    Dim SysexBytes As String
    Dim SysexListCount As Integer
    Dim x As Integer

    SysexListCount = ListSysex.ListCount

    On Error Resume Next
    CMDialog1.DialogTitle = "Load System Exclusive File"
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 1
    If (Err) Then
    Exit Sub
    End If
    Open CMDialog1.Filename For Binary As #1

    Do While EOF(1) <> True
    SysexBytes = " "
    Get #1, , SysexBytes
    DisplayBufferString(SysexListCount) = LTrim(DisplayBufferString(SysexListCount)) & " " & Hex(Asc(SysexBytes))
    Loop

    Close #1

    DisplayBufferString(SysexListCount) = Left(DisplayBufferString(SysexListCount), (Len(DisplayBufferString(SysexListCount)) - 2))

    ListSysex.AddItem CMDialog1.Filename & " Len =" & Str(Len(DisplayBufferString(SysexListCount)))

    'unselect all
    For x = 0 To ListSysex.ListCount - 1
    ListSysex.Selected(x) = False
    Next

    'Highlight the loaded file
    ListSysex.Selected(ListSysex.ListCount - 1) = True

End Sub

Sub mnuMidiSetup_Click ()
    MIDISetupForm.Show MODAL
End Sub

Sub mnuMidiThru_Click ()
    'Switch check mark on and off
    If mnuMidiThru.Checked = True Then
    mnuMidiThru.Checked = False
    Else
    mnuMidiThru.Checked = True
    End If
End Sub

Sub MnuSaveBankAs_Click ()
    Dim I As Integer
    Dim n As Integer
    Dim SysexMessage As String
    Dim StringPosition As Integer

    ' MIDI Data is being sent
    LblInQueue.Caption = " Saving data..."
    LblInQueue.Refresh

    On Error Resume Next
    CMDialog1.DialogTitle = "Save Selected Sysex Message"
    CMDialog1.Flags = &H1000&
    CMDialog1.Action = 2
    If (Err) Then
    Exit Sub
    End If

    Open CMDialog1.Filename For Binary As #1


    SysexMessage = ""

    'Look through ListSysex to see if you have selected some sysex
    'messages to send
    For I = 0 To ListSysex.ListCount - 1
    'When we first received the sysex message we reformated
    'it to make it easier to edit.  Now since we're going to send it,
    'we've got to get it back in its original format
    If ListSysex.Selected(I) = True Then

        ListSysex.ListIndex = I
        '

        'Start formating complete sysex message
        SysexMessage = Chr$("&H" + Left(DisplayBufferString(I), 2))

        'Write begining F0 sysex byte to file
        Put #1, , SysexMessage


        'Starting position of InStr search
        n = 3

        'We're going into this loop until we've reformated the complete
        'sysex message
        Do While Len(DisplayBufferString(I)) > n
        '
        'Since we've got a bunch of spaces " " that we've got
        'to find in our reformating, we're going to use the
        'InStr function to help us find them.  Look in the VB
        'Help file if you don't understand InStr!
        StringPosition = InStr(n, DisplayBufferString(I), " ")
        '
        'If 0 then we'll not put in the &H
        If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "0" Then
            SysexMessage = Chr$(Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
        Else
            'If not 0 but just null, then we do nothing
            If Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)) = "" Then
            'null
            Else
            SysexMessage = Chr$("&H" & Trim(Mid(DisplayBufferString(I), StringPosition + 1, 2)))
            End If
        End If

        'Write sysex data to file
        Put #1, , SysexMessage

        n = StringPosition + 2
        Loop
    End If
    Next I

    Close #1
End Sub

Sub TextSysex_Change ()
    'You can edit the sysex message.  If you do make changes
    'we'll update DisplayBufferString with those changes
    DisplayBufferString(ListSysex.ListIndex) = TextSysex.Text
End Sub